home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLBFUN.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-01-01  |  9.0 KB  |  420 lines
  1. /* xlbfun.c - xlisp basic builtin functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack;
  7. extern NODE *s_lambda,*s_macro;
  8. extern NODE *s_comma,*s_comat;
  9. extern NODE *s_unbound;
  10. extern char gsprefix[];
  11. extern int gsnumber;
  12.  
  13. /* forward declarations */
  14. FORWARD NODE *bquote1();
  15. FORWARD NODE *defun();
  16. FORWARD NODE *makesymbol();
  17.  
  18. /* xeval - the builtin function 'eval' */
  19. NODE *xeval(args)
  20.   NODE *args;
  21. {
  22.     NODE *oldstk,expr,*val;
  23.  
  24.     /* create a new stack frame */
  25.     oldstk = xlsave(&expr,NULL);
  26.  
  27.     /* get the expression to evaluate */
  28.     expr.n_ptr = xlarg(&args);
  29.     xllastarg(args);
  30.  
  31.     /* evaluate the expression */
  32.     val = xleval(expr.n_ptr);
  33.  
  34.     /* restore the previous stack frame */
  35.     xlstack = oldstk;
  36.  
  37.     /* return the expression evaluated */
  38.     return (val);
  39. }
  40.  
  41. /* xapply - the builtin function 'apply' */
  42. NODE *xapply(args)
  43.   NODE *args;
  44. {
  45.     NODE *oldstk,fun,arglist,*val;
  46.  
  47.     /* create a new stack frame */
  48.     oldstk = xlsave(&fun,&arglist,NULL);
  49.  
  50.     /* get the function and argument list */
  51.     fun.n_ptr = xlarg(&args);
  52.     arglist.n_ptr = xlarg(&args);
  53.     xllastarg(args);
  54.  
  55.     /* if the function is a symbol, get its value */
  56.     if (symbolp(fun.n_ptr))
  57.     fun.n_ptr = xleval(fun.n_ptr);
  58.  
  59.     /* apply the function to the arguments */
  60.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  61.  
  62.     /* restore the previous stack frame */
  63.     xlstack = oldstk;
  64.  
  65.     /* return the expression evaluated */
  66.     return (val);
  67. }
  68.  
  69. /* xfuncall - the builtin function 'funcall' */
  70. NODE *xfuncall(args)
  71.   NODE *args;
  72. {
  73.     NODE *oldstk,fun,arglist,*val;
  74.  
  75.     /* create a new stack frame */
  76.     oldstk = xlsave(&fun,&arglist,NULL);
  77.  
  78.     /* get the function and argument list */
  79.     fun.n_ptr = xlarg(&args);
  80.     arglist.n_ptr = args;
  81.  
  82.     /* if the function is a symbol, get its value */
  83.     if (symbolp(fun.n_ptr))
  84.     fun.n_ptr = xleval(fun.n_ptr);
  85.  
  86.     /* apply the function to the arguments */
  87.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  88.  
  89.     /* restore the previous stack frame */
  90.     xlstack = oldstk;
  91.  
  92.     /* return the expression evaluated */
  93.     return (val);
  94. }
  95.  
  96. /* xquote - builtin function to quote an expression */
  97. NODE *xquote(args)
  98.   NODE *args;
  99. {
  100.     NODE *arg;
  101.  
  102.     /* get the argument */
  103.     arg = xlarg(&args);
  104.     xllastarg(args);
  105.  
  106.     /* return the quoted expression */
  107.     return (arg);
  108. }
  109.  
  110. /* xbquote - back quote function */
  111. NODE *xbquote(args)
  112.   NODE *args;
  113. {
  114.     NODE *oldstk,expr,*val;
  115.  
  116.     /* create a new stack frame */
  117.     oldstk = xlsave(&expr,NULL);
  118.  
  119.     /* get the expression */
  120.     expr.n_ptr = xlarg(&args);
  121.     xllastarg(args);
  122.  
  123.     /* fill in the template */
  124.     val = bquote1(expr.n_ptr);
  125.  
  126.     /* restore the previous stack frame */
  127.     xlstack = oldstk;
  128.  
  129.     /* return the result */
  130.     return (val);
  131. }
  132.  
  133. /* bquote1 - back quote helper function */
  134. LOCAL NODE *bquote1(expr)
  135.   NODE *expr;
  136. {
  137.     NODE *oldstk,val,list,*last,*new;
  138.  
  139.     /* handle atoms */
  140.     if (atom(expr))
  141.     val.n_ptr = expr;
  142.  
  143.     /* handle (comma <expr>) */
  144.     else if (car(expr) == s_comma) {
  145.     if (atom(cdr(expr)))
  146.         xlfail("bad comma expression");
  147.     val.n_ptr = xleval(car(cdr(expr)));
  148.     }
  149.  
  150.     /* handle ((comma-at <expr>) ... ) */
  151.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  152.     oldstk = xlsave(&list,&val,NULL);
  153.     if (atom(cdr(car(expr))))
  154.         xlfail("bad comma-at expression");
  155.     list.n_ptr = xleval(car(cdr(car(expr))));
  156.     for (last = NULL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  157.         new = newnode(LIST);
  158.         rplaca(new,car(list.n_ptr));
  159.         if (last)
  160.         rplacd(last,new);
  161.         else
  162.         val.n_ptr = new;
  163.         last = new;
  164.     }
  165.     if (last)
  166.         rplacd(last,bquote1(cdr(expr)));
  167.     else
  168.         val.n_ptr = bquote1(cdr(expr));
  169.     xlstack = oldstk;
  170.     }
  171.  
  172.     /* handle any other list */
  173.     else {
  174.     oldstk = xlsave(&val,NULL);
  175.     val.n_ptr = newnode(LIST);
  176.     rplaca(val.n_ptr,bquote1(car(expr)));
  177.     rplacd(val.n_ptr,bquote1(cdr(expr)));
  178.     xlstack = oldstk;
  179.     }
  180.  
  181.     /* return the result */
  182.     return (val.n_ptr);
  183. }
  184.  
  185. /* xset - builtin function set */
  186. NODE *xset(args)
  187.   NODE *args;
  188. {
  189.     NODE *sym,*val;
  190.  
  191.     /* get the symbol and new value */
  192.     sym = xlmatch(SYM,&args);
  193.     val = xlarg(&args);
  194.     xllastarg(args);
  195.  
  196.     /* assign the symbol the value of argument 2 and the return value */
  197.     assign(sym,val);
  198.  
  199.     /* return the result value */
  200.     return (val);
  201. }
  202.  
  203. /* xsetq - builtin function setq */
  204. NODE *xsetq(args)
  205.   NODE *args;
  206. {
  207.     NODE *oldstk,arg,sym,val;
  208.  
  209.     /* create a new stack frame */
  210.     oldstk = xlsave(&arg,&sym,&val,NULL);
  211.  
  212.     /* initialize */
  213.     arg.n_ptr = args;
  214.  
  215.     /* handle each pair of arguments */
  216.     while (arg.n_ptr) {
  217.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  218.     val.n_ptr = xlevarg(&arg.n_ptr);
  219.     assign(sym.n_ptr,val.n_ptr);
  220.     }
  221.  
  222.     /* restore the previous stack frame */
  223.     xlstack = oldstk;
  224.  
  225.     /* return the result value */
  226.     return (val.n_ptr);
  227. }
  228.  
  229. /* xdefun - builtin function 'defun' */
  230. NODE *xdefun(args)
  231.   NODE *args;
  232. {
  233.     return (defun(args,s_lambda));
  234. }
  235.  
  236. /* xdefmacro - builtin function 'defmacro' */
  237. NODE *xdefmacro(args)
  238.   NODE *args;
  239. {
  240.     return (defun(args,s_macro));
  241. }
  242.  
  243. /* defun - internal function definition routine */
  244. LOCAL NODE *defun(args,type)
  245.   NODE *args,*type;
  246. {
  247.     NODE *oldstk,sym,fargs,fun;
  248.  
  249.     /* create a new stack frame */
  250.     oldstk = xlsave(&sym,&fargs,&fun,NULL);
  251.  
  252.     /* get the function symbol and formal argument list */
  253.     sym.n_ptr = xlmatch(SYM,&args);
  254.     fargs.n_ptr = xlmatch(LIST,&args);
  255.  
  256.     /* create a new function definition */
  257.     fun.n_ptr = newnode(LIST);
  258.     rplaca(fun.n_ptr,type);
  259.     rplacd(fun.n_ptr,newnode(LIST));
  260.     rplaca(cdr(fun.n_ptr),fargs.n_ptr);
  261.     rplacd(cdr(fun.n_ptr),args);
  262.  
  263.     /* make the symbol point to a new function definition */
  264.     assign(sym.n_ptr,fun.n_ptr);
  265.  
  266.     /* restore the previous stack frame */
  267.     xlstack = oldstk;
  268.  
  269.     /* return the function symbol */
  270.     return (sym.n_ptr);
  271. }
  272.  
  273. /* xgensym - generate a symbol */
  274. NODE *xgensym(args)
  275.   NODE *args;
  276. {
  277.     char sym[STRMAX+1];
  278.     NODE *x;
  279.  
  280.     /* get the prefix or number */
  281.     if (args) {
  282.     x = xlarg(&args);
  283.     switch (ntype(x)) {
  284.     case STR:
  285.         strcpy(gsprefix,x->n_str);
  286.         break;
  287.     case INT:
  288.         gsnumber = x->n_int;
  289.         break;
  290.     default:
  291.         xlfail("bad argument type");
  292.     }
  293.     }
  294.     xllastarg(args);
  295.  
  296.     /* create the pname of the new symbol */
  297.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  298.  
  299.     /* make a symbol with this print name */
  300.     return (xlmakesym(sym,DYNAMIC));
  301. }
  302.  
  303. /* xmakesymbol - make a new uninterned symbol */
  304. NODE *xmakesymbol(args)
  305.   NODE *args;
  306. {
  307.     return (makesymbol(args,FALSE));
  308. }
  309.  
  310. /* xintern - make a new interned symbol */
  311. NODE *xintern(args)
  312.   NODE *args;
  313. {
  314.     return (makesymbol(args,TRUE));
  315. }
  316.  
  317. /* makesymbol - make a new symbol */
  318. LOCAL NODE *makesymbol(args,iflag)
  319.   NODE *args; int iflag;
  320. {
  321.     NODE *oldstk,pname,*val;
  322.     char *str;
  323.  
  324.     /* create a new stack frame */
  325.     oldstk = xlsave(&pname,NULL);
  326.  
  327.     /* get the print name of the symbol to intern */
  328.     pname.n_ptr = xlmatch(STR,&args);
  329.     xllastarg(args);
  330.  
  331.     /* make the symbol */
  332.     str = pname.n_ptr->n_str;
  333.     val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
  334.  
  335.     /* restore the previous stack frame */
  336.     xlstack = oldstk;
  337.  
  338.     /* return the symbol */
  339.     return (val);
  340. }
  341.  
  342. /* xsymname - get the print name of a symbol */
  343. NODE *xsymname(args)
  344.   NODE *args;
  345. {
  346.     NODE *sym;
  347.  
  348.     /* get the symbol */
  349.     sym = xlmatch(SYM,&args);
  350.     xllastarg(args);
  351.  
  352.     /* return the print name */
  353.     return (car(sym->n_symplist));
  354. }
  355.  
  356. /* xsymvalue - get the print value of a symbol */
  357. NODE *xsymvalue(args)
  358.   NODE *args;
  359. {
  360.     NODE *sym;
  361.  
  362.     /* get the symbol */
  363.     sym = xlmatch(SYM,&args);
  364.     xllastarg(args);
  365.  
  366.     /* check for an unbound symbol */
  367.     while (sym->n_symvalue == s_unbound)
  368.     xlunbound(sym);
  369.  
  370.     /* return the value */
  371.     return (sym->n_symvalue);
  372. }
  373.  
  374. /* xsymplist - get the property list of a symbol */
  375. NODE *xsymplist(args)
  376.   NODE *args;
  377. {
  378.     NODE *sym;
  379.  
  380.     /* get the symbol */
  381.     sym = xlmatch(SYM,&args);
  382.     xllastarg(args);
  383.  
  384.     /* return the property list */
  385.     return (cdr(sym->n_symplist));
  386. }
  387.  
  388. /* xget - get the value of a property */
  389. NODE *xget(args)
  390.   NODE *args;
  391. {
  392.     NODE *sym,*prp;
  393.  
  394.     /* get the symbol and property */
  395.     sym = xlmatch(SYM,&args);
  396.     prp = xlmatch(SYM,&args);
  397.     xllastarg(args);
  398.  
  399.     /* retrieve the property value */
  400.     return (xlgetprop(sym,prp));
  401. }
  402.  
  403. /* xremprop - remove a property value from a property list */
  404. NODE *xremprop(args)
  405.   NODE *args;
  406. {
  407.     NODE *sym,*prp;
  408.  
  409.     /* get the symbol and property */
  410.     sym = xlmatch(SYM,&args);
  411.     prp = xlmatch(SYM,&args);
  412.     xllastarg(args);
  413.  
  414.     /* remove the property */
  415.     xlremprop(sym,prp);
  416.  
  417.     /* return nil */
  418.     return (NULL);
  419. }
  420.